home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
faq-s.zip
/
CHATSTUF.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-04-16
|
59KB
|
2,443 lines
{$R-,S-,I-,D-,F+,V-,B-,N-,L+ }
{$M 65500,0,0 }
unit chatstuf;
interface
uses crt,dos,
gentypes,gensubs,subs1,userret,flags,mainr1,modem,windows,statret,
configrt;
function specialcommand:boolean;
procedure specialseries;
procedure chat1 (gotospecial:boolean);
procedure chat2 (gotospecial:boolean);
implementation
const c1=15;
c2=12;
c3=15;
c4=11;
w2=24;
w3=42;
axis1=9;
axis2=10;
edituser:array [1..12] of string=
('┬───────────────────┬',
'│ User Name │',
'│ User Level │',
'│ Xfer Level │',
'│ Xfer Points │',
'│ User Note │',
'│ Time Left │',
'│ Password │',
'│ G-File Level │',
'│ Board Access │',
'│ Sysop Access │',
'└───────────────────┘');
utils:array [1..12] of string=
('┬───────────────────┬',
'│ Hang up on User │',
'│ Delete User │',
'│ Snoop Mode [On] │',
'│ Snoop Mode [Off] │',
'└───────────────────┘',
'',
'',
'',
'',
'',
'');
extra:array [1..12] of string=
('┬───────────────────────────┬',
'│ Drop to DOS (part memory) │',
'│ Run Setup Program │',
'│ Run User Editor │',
'│ Run Text Editor │',
'│ Run ANSI Editor │',
'└───────────────────────────┘',
'',
'',
'',
'',
'');
var dscinc:array [1..6] of array [1..60] of word;
Status:word;
type brdrrec = record
TL,TH,TR,LV,RV,BL,BH,BR:char;
end;
const border:brdrrec = (TL:'┌';TH:'─';TR:'┐';
LV:'│'; RV:'│';
BL:'└';BH:'─';BR:'┘');
{function specialcommand:boolean;
function getstring (t:anystr):anystr;
var mm,lz:anystr;
begin
textbackground (0);
textcolor (15);
gotoxy (axis1+3,axis2+2);
write (usr,t);
readline (mm);
getstring:=mm;
end;
function getint (t:lstr):integer;
var s:sstr;
begin
s:=getstring (t);
getint:=valu(s)
end;
function getboo (t:lstr):boolean;
var s:sstr;
begin
s:=getstring (t);
getboo:=upcase(s[1])='Y'
end;
procedure box;
(* procedure qbox (row,col,rows,cols:byte;wndwattr,brdrattr:integer;brdr:brdrrec);
begin
if (rows>=2) and (cols>=2) then
begin
with brdr do
begin
qwrite (row ,col ,brdrattr,TL);
qfilleos ( 1,cols-2,brdrattr,TH);
qwriteeos ( brdrattr,TR);
qfill (row+1 ,col ,rows-2,1 ,brdrattr,LV);
qfill (row+1 ,col+cols-1,rows-2,1 ,brdrattr,RV);
qwrite (row+rows-1,col ,brdrattr,BL);
qfilleos ( 1,cols-2,brdrattr,BH);
qwriteeos ( brdrattr,BR);
qfill (row+1 ,col+1 ,rows-2,cols-2,wndwattr,' ')
end;
end;
end; *)
begin
(* qstoretomem (axis1,axis2,6,60,dscinc);
qbox (axis1,axis2,6,60,15,9,border); *)
end;
procedure done1;
begin
(* qstoretoscr (axis1,axis2,6,60,dscinc); *)
end;
procedure write1 (l:lstr);
begin
gotoxy (axis1+3,axis2+1);
textcolor (15);
textbackground (0);
writeln (usr,l);
end;
procedure getnewtime;
var q:integer;
n:integer;
begin
n:=timeleft;
box;
write1 ('The user has '+strr(n)+' minutes left.');
q:=getint ('New time left for today? ');
if q>0 then begin
urec.timetoday:=urec.timetoday+(q-n);
writeurec;
writeln ('You have been granted '+strr(timeleft)+' minutes for today.')
end;
end;
procedure getnewlevel;
var q,n:integer;
begin
box;
write1 ('Current Level: '+strr(ulvl));
q:=getint ('New Level [-1 to TRASH]: ');
if q>0 then begin
n:=q;
ulvl:=n;
urec.level:=n;
writeurec;
writeln ('You have been granted Level ',n,' access.');
if n=-1 then writeln ('That means you''ve been thrown off this system. Hahah.')
end
end;
procedure getnewgflevel;
var q,n:integer;
begin
box;
write1 ('Current G-File Level: '+strr(urec.gflevel));
q:=getint ('New G-File Level: ');
if q>0 then begin
n:=q;
urec.gflevel:=n;
writeurec;
writeln ('You have been granted Level ',n,' G-File access.');
end
end;
procedure getnewaccess;
var q,bname:sstr;
bn:integer;
ac:accesstype;
wasopen:boolean;
k:char;
function inputaccess (q:sstr):accesstype;
begin
inputaccess:=invalid;
if length(q)=0 then exit;
case upcase(q[1]) of
'L':inputaccess:=letin;
'B':inputaccess:=bylevel;
'K':inputaccess:=keepout
end
end;
procedure getallaccess;
procedure setallaccess (ac:accesstype);
var cnt:integer;
begin
setalluserflags (urec,ac);
writeln ('Your access to all sub-boards: ',accessstr[ac]);
writeurec
end;
begin
buflen:=1;
q:=getstring ('ALL acc. ([B]y level, [L]et in, [K]eep out, or CR): ');
ac:=inputaccess(q);
if ac<>invalid then setallaccess(ac)
end;
var bd:boardrec;
begin
box;
write1 ('Change Sub-Board Access');
buflen:=10;
bname:=getstring ('Which sub-board to change access for [''*''/All]: ');
if length(bname)<1 then exit;
if bname='*' then
begin
getallaccess;
exit
end;
opentempbdfile;
bn:=searchboard(bname);
if bn=-1 then
begin
closetempbdfile;
write1 ('No such board! Press any key..');
k:=bioskey;
exit
end;
write1 ('Board '+bname+'... Current access: '+accessstr[getuseraccflag(urec,bn)]);
buflen:=1;
q:=getstring ('Access ([B]y level, [L]et in, [K]eep out, or [CR]: ');
ac:=inputaccess(q);
if ac=invalid then begin
closetempbdfile;
exit
end;
setuseraccflag (urec,bn,ac);
writeurec;
closetempbdfile;
writeln ('New access for sub-board ',bname,': ',accessstr[ac])
end;
procedure hangupyn;
var q:sstr;
begin
box;
write1 ('Hang up on User');
q:=getstring ('Hang up on him? [y/n]: ');
if length(q)>0 then if upcase(q[1])='Y' then
begin
writeln (unam,' the System is going down.'^M^M);
hangup;
forcehangup:=true;
specialcommand:=true
end
end;
procedure getnewname;
var m:mstr;
n:integer;
t:string[1];
begin
box;
write1 ('Current Name: '+unam);
m:=getstring ('New User Name: ');
if length(m)<>0 then begin
n:=lookupuser(m);
if n<>0 then begin
buflen:=1;
t:=getstring ('Name already exists! Are you sure? ');
if upcase(t[1])<>'Y' then exit
end;
unam:=m;
urec.handle:=m;
writeurec;
writeln ('Your Name has been changed to ',unam,'.')
end
end;
procedure getnewpassword;
var m:mstr;
begin
box;
write1 ('Current Password: '+urec.password);
m:=getstring ('New Password: ');
if length(m)<>0 then
begin
urec.password:=m;
writeurec;
writeln ('Your Password has been changed.')
end
end;
procedure getxferlevel;
var i:integer;
begin
box;
write1 ('Current Xfer Level: '+strr(urec.udlevel));
i:=getint ('New File Xfer Level: ');
if i<0 then exit
else begin
writeln ('You have been granted Level ',i,' File Xfer access.');
urec.udlevel:=i;
writeurec;
end;
end;
procedure getxferpoints;
var i:integer;
begin
box;
write1 ('Current Xfer Points: '+strr(urec.udpoints));
i:=getint ('New File Xfer Points: ');
if i<0 then exit
else begin
writeln ('You have been granted ',i,' File Xfer points.');
urec.udpoints:=i;
writeurec;
end;
end;
procedure snoopmode;
begin
box;
write1 ('All I/O to the modem is locked.');
delay (500);
modeminlock:=true;
setoutlock (true)
end;
procedure unsnoop;
begin
box;
write1 ('All I/O to the modem is re-enabled.');
delay (500);
modeminlock:=false;
setoutlock (false)
end;
procedure makenote;
var mastermind:mstr;
begin
box;
write1 ('Current Note: '+urec.note);
buflen:=30;
mastermind:=getstring ('New Note: ');
if length(mastermind)<>0 then begin
urec.note:=mastermind;
writeurec;
writeln ('Your User Note has been changed to: ',mastermind);
end;
end;
procedure gotodos (i:integer);
begin
writeln ('Sysop in DOS:');
window (1,1,80,25);
gotoxy (1,25);
writeln (usr,^M^J^J^J);
updateuserstats (false);
execcomcom;
end;
procedure runconfig;
begin
window (1,1,80,25);
textbackground(0);
gotoxy (1,25);
writeln (usr,^M^J^J^J);
updateuserstats (false);
ensureclosed;
if faqdir[length(faqdir)]<>'\' then faqdir:=faqdir+'\';
cursor (true);
Exec(GetEnv('COMSPEC'), '/C '+faqdir+'SETUP.EXE');
cursor (false);
readconfig;
if datascrambling then scrambled:=true else scrambled:=false;
chdir (copy(faqdir,1,length(faqdir)-1));
end;
procedure dotexteditor;
begin
textbackground(0);
if length(editor)<1 then exit;
writeln ('Sysop is loading text editor:');
window (1,1,80,25);
gotoxy (1,25);
writeln (usr,^M^J^J^J);
updateuserstats (false);
ensureclosed;
cursor (true);
exec(GetEnv('COMSPEC'), '/C '+editor);
cursor (false);
chdir (copy(faqdir,1,length(faqdir)-1));
end;
procedure doansieditor;
begin
textbackground(0);
if length(ansiedit)<1 then exit;
writeln ('Sysop is loading ansi editor:');
window (1,1,80,25);
gotoxy (1,25);
writeln (usr,^M^J^J^J);
updateuserstats (false);
ensureclosed;
cursor (true);
exec(GetEnv('COMSPEC'), '/C '+ansiedit);
cursor (false);
chdir (copy(faqdir,1,length(faqdir)-1));
end;
procedure printf (fn:lstr);
procedure getextension (var fname:lstr);
procedure tryfiles (a,b,c,d:integer);
var q:boolean;
function tryfile (n:integer):boolean;
const exts:array [1..4] of string[3]=('','ANS','ASC','40');
begin
if not exist (fname+'.'+exts[n]) then tryfile:=false else begin
tryfile:=true;
fname:=fname+'.'+exts[n]
end
end;
begin
if tryfile (a) then exit;
if tryfile (b) then exit;
if tryfile (c) then exit;
q:=tryfile (d)
end;
begin
if pos ('.',fname)<>0 then exit;
if ansigraphics in urec.config then tryfiles (2,3,1,4) else
if asciigraphics in urec.config then tryfiles (3,1,4,2) else
if eightycols in urec.config then tryfiles (1,4,3,2) else
tryfiles (4,1,3,2)
end;
var tf:text;
k:char;
begin
clearbreak;
writeln;
getextension (fn);
assign (tf,fn);
reset (tf);
iocode:=ioresult;
if iocode<>0 then begin
fileerror ('Printfile',fn);
exit
end;
clearbreak;
while not (eof(tf) or break or hungupon) do
begin
read (tf,k);
write (k)
end;
if break then writeln (^B);
writeln;
textclose (tf);
curattrib:=0;
ansireset
end;
procedure nuke;
var q:sstr;
u:userrec;
n,x:integer;
begin
box;
q:=getstring ('Delete User? [y/n]: ');
if length(q)>0 then if upcase(q[1])='Y' then
begin
write1 ('You''re Deleted!');
deleteuser (unum);
for n:=1 to numusers do begin
seek (ufile,n);
read (ufile,u);
for x:=1 to 50 do
u.newvoteit[x]:=0;
writeufile (u,n);
end;
readurec;
if exist (textfiledir+'Delete') then
printf (textfiledir+'Delete') else
writeln ('Don''t Call Again!'^M^M);
hangup;
forcehangup:=true;
specialcommand:=true
end
end;
procedure getsysopaccess;
const sysopstr:array [false..true] of string[6]=('Normal','Sysop');
sectionnames:array [udsysop..gfsysop] of string[20]=
('File Transfer','Bulletin Section','Voting Booths',
'E-Mail Section','Doors','Main Menu','Databases','Trivia Sysop',
'G-File Section');
var cnt:configtype;
x:string[10];
n,mx:integer;
v:boolean;
begin
repeat
splitscreen (12);
clrscr; textbackground(0);
textcolor (15);
mx:=1;
for cnt:=udsysop to gfsysop do begin
write (usr,mx:3,'. ',sectionnames[cnt]);
mx:=mx+1;
gotoxy (25,wherey);
writeln (usr,sysopstr[cnt in urec.config])
end;
write (usr,^M^J'Number to toggle [CR/Exit]: ');
buflen:=1;
readline (x);
n:=valu(x);
v:=(n>0) and (n<mx);
if v then begin
cnt:=configtype(ord(udsysop)+n-1);
if cnt in urec.config
then
begin
urec.config:=urec.config-[cnt];
x:='denied'
end
else
begin
urec.config:=urec.config+[cnt];
x:='granted'
end;
writeln ('You have been ',x,' sysop priveleges for the ',
sectionnames[cnt],'.')
end
until not v;
writeurec;
clrscr;
splitscreen (17);
exit;
end;
procedure runusereditor;
begin
window (1,1,80,25);
gotoxy (1,25);
textbackground (0);
writeln (usr,^M^J^J^J);
(* updateuserstats (false);
ensureclosed; *)
if faqdir[length(faqdir)]<>'\' then faqdir:=faqdir+'\';
Exec(GetEnv('COMSPEC'), '/C FAQUE.EXE');
if datascrambling then scrambled:=true else scrambled:=false;
clrscr;
end;
procedure cursor (csize:byte);
var regs:registers;
begin
case (csize) of
1: if mem[0:$449]=7 then regs.cx:=$0c0d (* Underline = 1 *)
else regs.cx:=$0607;
2: if mem[0:$449]=7 then regs.cx:=$060d (* Full Block = 2 *)
else regs.cx:=$0007;
3: regs.cx:=$2000; (* No Cursor = 3 *)
end;
regs.ax:=$0100;
intr ($10,regs);
end;
const memrows=25;
memcols=80;
var scom:char;
k,c:char;
quit:boolean;
x,y:integer;
procedure writetop;
begin
gotoxy (1,1);
textbackground (1);
textcolor (c1);
cursor (3);
writeln (usr,'┌───────────────────────────────────────────────────────────────────────┐');
write (usr,'│ ');
textcolor (c1);
write (usr,'User Editing Utilities Extra Commands');
textcolor (c1);
writeln (usr,' │');
writeln (usr,'└───────────────────────────────────────────────────────────────────────┘');
(* gotoxy (1,16);
textcolor (15);
textbackground (4);
write (usr,'[ Sysop Pull Down Menu System - '+#24+','+#25+','+#26+','+#27+',Home,End to Move - [CR] to Select ]');
*) textbackground (0);
end;
procedure writebar (s:anystr);
var monolith:integer;
begin
textbackground (1);
textcolor (11);
for monolith:=1 to length(s) do
begin
if s[monolith] in [' '..'~'] then begin
textbackground (1);
textcolor (11);
write (usr,s[monolith]);
end else
begin
textbackground (1);
textcolor (15);
write (usr,s[monolith]);
end;
end;
textbackground (1);
end;
procedure movebar (xx:integer; dir:char);
var satan,dogchild,floyd:integer;
begin
dir:=upcase(dir);
case x of
1:begin
textcolor (c1);
textbackground (1);
satan:=y;
gotoxy (3,satan+2);
write (usr,edituser[satan]);
if dir='U' then y:=y-1 else
if dir='D' then y:=y+1 else
if dir='S' then y:=y;
if y>11 then y:=2;
if y<2 then y:=11;
gotoxy (3,y+2);
writebar (edituser[y]);
end;
2:begin
textcolor (c1);
textbackground (1);
dogchild:=y;
gotoxy (w2,dogchild+2);
write (usr,utils[dogchild]);
if dir='U' then y:=y-1 else
if dir='D' then y:=y+1 else
if dir='S' then y:=y;
if y>5 then y:=2;
if y<2 then y:=5;
gotoxy (w2,y+2);
writebar (utils[y]);
end;
3:begin
textcolor (c1);
textbackground (1);
floyd:=y;
gotoxy (w3,floyd+2);
write (usr,extra[floyd]);
if dir='U' then y:=y-1 else
if dir='D' then y:=y+1 else
if dir='S' then y:=y;
if y>6 then y:=2;
if y<2 then y:=6;
gotoxy (w3,y+2);
writebar (extra[y]);
end;
end;
end;
procedure movebox (ex,ey:integer);
var anarky,burger,two:integer;
begin
cursor (3);
case ex of
1:begin
if x=2 then begin
gotoxy (w2,2);
textcolor (c1);
textbackground (1);
write (usr,' Utilities');
textcolor (c1);
gotoxy (w2,3);
write (usr,'───────────────────────────');
end else
if x=3 then begin
gotoxy (w3,2);
textcolor (c1);
textbackground (1);
write (usr,' Extra Commands');
textcolor (c1);
gotoxy (w3,3);
write (usr,'─────────────────────────────');
end;
x:=1;
gotoxy (3,2);
textbackground (1);
textcolor (c4);
write (usr,'User Editing');
textcolor (c3);
for anarky:=1 to 12 do
begin
gotoxy (3,anarky+2);
write (usr,edituser[anarky]);
end;
if y>10 then y:=1;
textbackground (1);
end;
2:begin
if x=1 then begin
gotoxy (3,2);
textcolor (c1);
textbackground (1);
write (usr,'User Editing');
textcolor (c1);
gotoxy (3,3);
write (usr,'─────────────────────');
end else
if x=3 then begin
gotoxy (w3,2);
textcolor (c1);
textbackground (1);
write (usr,' Extra Commands');
textcolor (c1);
gotoxy (w3,3);
write (usr,'─────────────────────────────');
end;
x:=2;
gotoxy (w2,2);
textbackground (1);
textcolor (c4);
write (usr,' Utilities');
textcolor (c3);
for burger:=1 to 6 do
begin
gotoxy (w2,burger+2);
write (usr,utils[burger]);
textbackground (1);
textcolor (c3);
end;
end;
3:begin
if x=1 then begin
gotoxy (3,2);
textcolor (c1);
textbackground (1);
write (usr,'User Editing');
textcolor (c1);
gotoxy (3,3);
write (usr,'─────────────────────');
end else
if x=2 then begin
gotoxy (w2,2);
textcolor (c1);
textbackground (1);
write (usr,' Utilities');
textcolor (c1);
gotoxy (w2,3);
write (usr,'──────────────────────');
end;
x:=3;
gotoxy (w3,2);
textbackground (1);
textcolor (c4);
write (usr,' Extra Commands');
textcolor (c3);
for two:=1 to 7 do
begin
gotoxy (w3,two+2);
write (usr,extra[two]);
textbackground (1);
textcolor (c3);
end;
end;
end;
end;
procedure eraseall;
begin
(* qfill (4,1,11,80,black+blackbg,' '); *)
textbackground (0);
clrscr;
writetop;
end;
procedure movedown (x,y:integer);
begin
movebar (x,'D');
end;
procedure moveup (x,y:integer);
begin
movebar (x,'U');
end;
procedure moveright (x,y:integer);
begin
y:=1;
x:=x+1;
if x>3 then x:=1;
eraseall;
y:=1;
movebox (x,y);
movebar (x,'S');
end;
procedure moveleft (x,y:integer);
begin
y:=1;
x:=x-1;
if x<1 then x:=3;
eraseall;
y:=1;
movebox (x,y);
y:=1;
movebar (x,'S');
end;
function processcommand:char;
begin
cursor (1);
case x of
1:begin
case y of
2:getnewname;
3:getnewlevel;
4:getxferlevel;
5:getxferpoints;
6:makenote;
7:getnewtime;
8:getnewpassword;
9:getnewgflevel;
10:getnewaccess;
11:getsysopaccess;
end;
end;
2:begin
case y of
2:hangupyn;
3:nuke;
4:snoopmode;
5:unsnoop;
end;
end;
3:begin
case y of
2:begin gotodos (1); clrscr; end;
3:begin runconfig; clrscr; end;
4:begin runusereditor; clrscr; end;
5:begin dotexteditor; clrscr; end;
6:begin doansieditor; clrscr; end;
end;
end;
end;
cursor (3);
case x of
1:begin
case y of
2:processcommand:='N';
3:processcommand:='L';
4:processcommand:='F';
5:processcommand:='F';
6:processcommand:='R';
7:processcommand:='T';
8:processcommand:='P';
9:processcommand:='G';
10:processcommand:='B';
11:processcommand:='Y';
end;
end;
2:begin
case y of
2:processcommand:='H';
3:processcommand:='N';
4:begin
processcommand:='S';
quit:=true;
end;
5:begin
processcommand:='Z';
quit:=true;
end;
end;
end;
3:begin
case y of
2:processcommand:='D';
3:processcommand:='C';
4:processcommand:='U';
5:processcommand:='E';
6:processcommand:='A';
end;
quit:=true;
end;
end;
done1;
end;
begin
writeln (^B^M'Please Wait:');
splitscreen (17);
top;
clrscr;
specialcommand:=false;
x:=1;
y:=2;
writetop;
movebox (x,y);
movebar (x,'S');
quit:=false;
repeat
c:=bioskey;
case ord(c) of
27:begin
quit:=true;
scom:='Q';
end;
13:scom:=processcommand;
208:movedown (x,y);
200:moveup (x,y);
203:moveleft (x,y);
205:moveright (x,y);
199:begin
y:=2;
movebox (x,y);
movebar (x,'S');
end;
207:begin
if x>1 then y:=5 else y:=11;
movebox (x,y);
movebar (x,'S');
end;
end;
until quit;
cursor (1);
bottomline;
specialcommand:=scom in ['Q','S','Z','D','C','U','E'];
unsplit
end;}
Function specialcommand:Boolean;
Procedure getnewtime;
Var q:sstr;
n:Integer;
Begin
n:=timeleft;
WriteLn(Usr,'The user has ',n,' minutes left.');
Write(Usr,'New Time Left: ');
cursor (true);
readline(q);
cursor (false);
If Length(q)>0 Then Begin
urec.timetoday:=urec.timetoday+(valu(q)-n);
writeurec;
{ writeln ('You have been granted ',timeleft,' minutes for today.')
}End
End;
Procedure getnewlevel;
Var q:sstr;
n:Integer;
Begin
WriteLn(Usr,'Current Main Level: ',ulvl);
Write(Usr,'New Main Level [-1 to trash]: ');
cursor (true);
readline(q);
cursor (false);
If Length(q)>0 Then Begin
n:=valu(q);
ulvl:=n;
urec.level:=n;
writeurec;
{ writeln ('You have been granted level ',n,' access.');
if n=-1 then writeln ('That means you''ve been kicked off this system.')
}End
End;
Procedure gfilez;
Var q:sstr;
n:Integer;
Begin
WriteLn(Usr,'Current G-File level: ',urec.gflevel);
Write(Usr,'New G-File Level: ');
cursor (true);
readline(q);
cursor (false);
If Length(q)>0 Then Begin
n:=valu(q);
urec.gflevel:=n;
writeurec;
End;
End;
Procedure hangupyn;
Var q:sstr;
Begin
textbackground (0);
gotoxy (1,13);
Write(Usr,'Hang Up on User? ');
cursor (true);
readline(q);
cursor (false);
If Length(q)>0 Then If UpCase(q[1])='Y' Then
Begin
WriteLn('Call back later!'^M);
hangup;
forcehangup:=True;
specialcommand:=True
End
End;
Procedure getnewname;
Var m:mstr;
n:Integer;
t:String[1];
Begin
WriteLn(Usr,'Current Handle: ',unam);
Write(Usr,'New Handle: ');
cursor (true);
readline(m);
cursor (false);
If Length(m)<>0 Then Begin
n:=lookupuser(m);
If n<>0 Then Begin
Write(Usr,'Name already exists! Are you sure? ');
BufLen:=1;
cursor (true);
readline(t);
buflen:=80;
cursor (false);
If UpCase(t[1])<>'Y' Then exit
End;
unam:=m;
urec.handle:=m;
writeurec;
End;End;
Procedure getnewpassword;
Var m:mstr;
Begin
WriteLn(Usr,'Current Password: ',urec.password);
Write(Usr,'New Password: ');
cursor (true);
readline(m);
cursor (false);
If Length(m)<>0 Then Begin
urec.password:=m;
writeurec;
End
End;
Procedure getnewudlvl;
Var m:mstr;
i:integer;
Begin
WriteLn(Usr,'Current Xfer Level: ',urec.udlevel);
write (usr,'New Xfer Level: ');
cursor (true);
readline(m);
cursor (false);
If Length(m)>0 Then Begin
i:=valu(m);
urec.udlevel:=i;
writeurec;
End
End;
Procedure getnewudpts;
Var m:mstr;
i:integer;
Begin
WriteLn(Usr,'Current Xfer Points: ',urec.udpoints);
write (usr,'New Xfer Points: ');
cursor (true);
readline(m);
cursor (false);
If Length(m)>0 Then Begin
i:=valu(m);
urec.udpoints:=i;
writeurec;
End
End;
procedure printf (fn:lstr);
procedure getextension (var fname:lstr);
procedure tryfiles (a,b,c,d:integer);
var q:boolean;
function tryfile (n:integer):boolean;
const exts:array [1..4] of string[3]=('','ANS','ASC','40');
begin
if not exist (fname+'.'+exts[n]) then tryfile:=false else begin
tryfile:=true;
fname:=fname+'.'+exts[n]
end
end;
begin
if tryfile (a) then exit;
if tryfile (b) then exit;
if tryfile (c) then exit;
q:=tryfile (d)
end;
begin
if pos ('.',fname)<>0 then exit;
if ansigraphics in urec.config then tryfiles (2,3,1,4) else
if asciigraphics in urec.config then tryfiles (3,1,4,2) else
if eightycols in urec.config then tryfiles (1,4,3,2) else
tryfiles (4,1,3,2)
end;
var tf:text;
k:char;
begin
clearbreak;
writeln;
getextension (fn);
assign (tf,fn);
reset (tf);
iocode:=ioresult;
if iocode<>0 then begin
fileerror ('Printfile',fn);
exit
end;
clearbreak;
while not (eof(tf) or break or hungupon) do
begin
read (tf,k);
write (k)
end;
if break then writeln (^B);
writeln;
textclose (tf);
curattrib:=0;
ansireset
end;
procedure nuke;
var q:sstr;
u:userrec;
n,x:integer;
begin
textbackground (0);
gotoxy (1,13);
Write(Usr,'Delete User? ');
cursor (true);
readline(q);
cursor (false);
If Length(q)>0 Then If UpCase(q[1])='Y' Then
Begin
writeln ('You''re Deleted!'^M);
deleteuser (unum);
for n:=1 to numusers do begin
seek (ufile,n);
read (ufile,u);
for x:=1 to 50 do
u.newvoteit[x]:=0;
writeufile (u,n);
end;
readurec;
if exist (textfiledir+'Delete') then
printf (textfiledir+'Delete') else
writeln ('Don''t Call Again!'^M^M);
hangup;
forcehangup:=true;
specialcommand:=true
end
end;
Procedure snoopmode;
Begin
WriteLn(Usr,'All I/O to the modem is locked.');
modeminlock:=True;
setoutlock(True)
End;
Procedure unsnoop;
Begin
WriteLn(Usr,'I/O to the modem is re-enabled.');
modeminlock:=False;
setoutlock(False)
End;
procedure gotodos;
begin
writeln ('Sysop in DOS:');
window (1,1,80,25);
gotoxy (1,25);
writeln (usr,^M^J^J^J);
{updateuserstats (false);}
cursor (true);
execcomcom;
cursor (false);
end;
procedure runconfig;
begin
window (1,1,80,25);
textbackground(0);
gotoxy (1,25);
writeln (usr,^M^J^J^J);
(* updateuserstats (false);
ensureclosed; *)
if faqdir[length(faqdir)]<>'\' then faqdir:=faqdir+'\';
cursor (true);
Exec(GetEnv('COMSPEC'), '/C '+faqdir+'SETUP.EXE');
cursor (false);
readconfig;
if datascrambling then scrambled:=true else scrambled:=false;
chdir (copy(faqdir,1,length(faqdir)-1));
end;
procedure dotexteditor;
begin
textbackground(0);
if length(editor)<1 then exit;
writeln ('Sysop is loading text editor:');
window (1,1,80,25);
gotoxy (1,25);
writeln (usr,^M^J^J^J);
(* updateuserstats (false);
ensureclosed; *)
cursor (true);
exec(GetEnv('COMSPEC'), '/C '+editor);
cursor (false);
chdir (copy(faqdir,1,length(faqdir)-1));
end;
procedure doansieditor;
begin
textbackground(0);
if length(ansiedit)<1 then exit;
writeln ('Sysop is loading ansi editor:');
window (1,1,80,25);
gotoxy (1,25);
writeln (usr,^M^J^J^J);
(* updateuserstats (false);
ensureclosed; *)
cursor (true);
exec(GetEnv('COMSPEC'), '/C '+ansiedit);
cursor (false);
chdir (copy(faqdir,1,length(faqdir)-1));
end;
Procedure getsysopaccess;
Const sysopstr:Array[false..true] Of String[6]=('Normal','Sysop');
sectionnames:Array[udsysop..databasesysop] Of String[20]=
('File transfer','Bulletin section','Voting booths',
'E-mail section','Doors','Main menu','Databases');
Var cnt:configtype;
x:String[10];
n,mx:Integer;
v:Boolean;
Begin
Repeat
ClrScr;
mx:=1;
For cnt:=udsysop To databasesysop Do Begin
Write(Usr,mx:3,'. ',sectionnames[cnt]);
mx:=mx+1;
GoToXY(25,WhereY);
WriteLn(Usr,sysopstr[cnt In urec.config])
End;
Write(Usr,^M^J'Number to toggle [CR to exit]: ');
BufLen:=1;
cursor (true);
readline(x);
cursor (false);
n:=valu(x);
v:=(n>0) And (n<mx);
If v Then Begin
cnt:=configtype(Ord(udsysop)+n-1);
If cnt In urec.config
Then
Begin
urec.config:=urec.config-[cnt];
x:='denied'
End
Else
Begin
urec.config:=urec.config+[cnt];
x:='granted'
End;
{ writeln ('You have been ',x,' sysop priveleges for the ',
sectionnames[cnt],'.')
}End
Until Not v;
writeurec
End;
procedure Pulldownmenu;
procedure ahigh (x:integer);
var c:char;
y,z,a:integer;
dir:string[127];
begin
case x of
1:begin
gotoxy (2,3);
textbackground (1);
textcolor (15);
write (usr,' Root Directory ');
textbackground (15);
textcolor (4);
end;
2:begin
gotoxy (2,4);
textbackground (1);
textcolor (15);
write (usr,' Other Dir ');
textbackground (15);
textcolor (4);
end;
end;
end;
procedure high (x:integer);
begin
case x of
1:begin
gotoxy (2,2);
textbackground (7);
textcolor (15);
write (usr,' User Editor ');
end;
2:begin
gotoxy (16,2);
textbackground (7);
textcolor (15);
write (usr,' External ');
end;
3:begin
gotoxy (27,2);
textbackground (7);
textcolor (15);
write (usr,' Shell to DOS ');
end;
4:begin
gotoxy (42,2);
textbackground (7);
textcolor (15);
write (usr,' Hang Up ');
end;
5:begin
gotoxy (52,2);
textbackground (7);
textcolor (15);
write (usr,' Delete User ');
end;
6:begin
gotoxy (66,2);
textbackground (7);
textcolor (15);
write (usr,' Help ');
end;
7:begin
gotoxy (73,2);
textbackground (7);
textcolor (15);
write (usr,' Quit ');
end;
end;
end;
procedure dohelp;
begin
gotoxy (25,10);
textbackground (1);
textcolor (15);
writeln (usr,'┌──────────────────────┐');
gotoxy (25,11);
write (usr,'│ ');
textcolor (11);
write (#27,#26,#25,#24+' - Move Bar');
textcolor (15);
writeln (usr,' │');
gotoxy (25,12);
write (usr,'│ ');
textcolor (11);
write (usr,' [Return] - Select');
textcolor (15);
writeln (usr,' │');
gotoxy (25,13);
write (usr,'│ ');
textcolor (11);
write (usr,' ESC - Quits to Main ');
textcolor (15);
writeln (usr,'│');
gotoxy (25,14);
writeln (usr,'└──────────────────────┘');
repeat
until keypressed;
end;
procedure changedir2;
var c:char;
x,y,z,a:integer;
dir:string[127];
begin
gotoxy (6,10);
textbackground (1);
textcolor (15);
writeln (usr,'┌─── Enter Directory ──────────────┐');
gotoxy (6,11);
writeln (usr,'│ │');
gotoxy (6,12);
writeln (usr,'└──────────────────────────────────┘');
gotoxy (8,11);
textcolor (14);
cursor (true);
readln (dir);
cursor (false);
if doserror <> 0 then begin
gotoxy (1,14);
textcolor (15);
textbackground (0);
writeln (usr,'Invalid Directory!');
exit;
end;
chdir (dir);
textbackground (0);
gotoxy (6,10);
clreol;
gotoxy (6,11);
clreol;
gotoxy (6,12);
clreol;
end;
procedure changedir;
var c:char;
x,y,z,a:integer;
dir:string[127];
begin
textbackground (1);
textcolor (15);
ahigh (y);
gotoxy (1,5);
writeln (usr,'┌────────────────┐');
writeln (usr,'│ Root Directory │');
writeln (usr,'│ Other Dir │');
writeln (usr,'└────────────────┘');
textbackground (1);
textcolor (15);
gotoxy (2,2);
ahigh (y);
repeat
c:=readkey;
c:=upcase (c);
until c in [#77,#75,#72,#80,#27,#13];
if (c=#77) or (c=#80) then y:=y+1;
if (c=#75) or (c=#72) then y:=y-1;
if y=3 then y:=1;
if y=0 then y:=2;
if c=#27 then exit;
if c=#13 then begin;
case y of
1:chdir('\');
2:changedir2;
end;
end;
changedir
end;
procedure makedir;
var c:char;
x,y,z,a:integer;
dir:string[127];
begin
gotoxy (6,10);
textbackground (1);
textcolor (15);
writeln (usr,'┌─── Enter Directory ──────────────┐');
gotoxy (6,11);
writeln (usr,'│ │');
gotoxy (6,12);
writeln (usr,'└──────────────────────────────────┘');
gotoxy (8,11);
textcolor (14);
cursor (true);
readln (dir);
cursor (false);
if doserror <> 0 then begin
writeln (usr,'Invalid Directory Name!');
exit;
end;
mkdir (dir);
textbackground (0);
gotoxy (6,10);
clreol;
gotoxy (6,11);
clreol;
gotoxy (6,12);
clreol;
end;
procedure copyproc;
var c:char;
x,y,z,a:integer;
dir:string[127];
var cf,ct:string;
begin
gotoxy (1,8);
textcolor (14);
textbackground (1);
writeln (usr,'┌── Copy ───────────────────────────────────────────┐');
writeln (usr,'│ │');
writeln (usr,'└───────────────────────────────────────────────────┘');
gotoxy (3,9);
textcolor (15);
cursor (true);
readln (cf);
cursor (false);
if doserror <> 0 then begin
writeln (usr,'Invalid Filename or File doesn''t Exist!');
exit;
end;
gotoxy (1,12);
textcolor (14);
writeln (usr,'┌── To ─────────────────────────────────────────────┐');
writeln (usr,'│ │');
writeln (usr,'└───────────────────────────────────────────────────┘');
gotoxy (3,13);
textcolor (15);
cursor (true);
readln (ct);
cursor (false);
if length(ct)=0 then begin
writeln (usr,'Invalid Directory or Filename!');
exit;
end;
gotoxy (1,17);
textcolor (11);
textbackground (0);
write (usr,'Copying ');
textcolor (15);
write (cf);
textcolor (11);
write (usr,' to ');
textcolor (15);
write (ct);
textcolor (11);
write (usr,'.');
exec(getenv('COMSPEC'),'/C copy '+cf+' '+ct);
gotoxy (1,8);
for a:=8 to 18 do begin
gotoxy (1,a);
clreol;
end;
end;
procedure moveproc;
var mf,mt:string;
var c:char;
x,y,z,a:integer;
dir:string[127];
begin
gotoxy (1,8);
textcolor (14);
textbackground (1);
writeln (usr,'┌── Move ───────────────────────────────────────────┐');
writeln (usr,'│ │');
writeln (usr,'└───────────────────────────────────────────────────┘');
gotoxy (3,9);
textcolor (15);
cursor (true);
readln (mf);
cursor (false);
if length(mf)=0 then begin
writeln (usr,'Invalid Filename!');
exit;
end;
gotoxy (1,12);
textcolor (14);
writeln (usr,'┌── To ─────────────────────────────────────────────┐');
writeln (usr,'│ │');
writeln (usr,'└───────────────────────────────────────────────────┘');
gotoxy (3,13);
textcolor (15);
cursor (true);
readln (mt);
cursor (false);
if length(mt)=0 then begin
writeln (usr,'Invalid Directory or Filename!');
exit;
end;
gotoxy (1,16);
textcolor (11);
write (usr,'Moving ');
textcolor (15);
write (mf);
textcolor (11);
write (usr,'to ');
textcolor (15);
write (mt);
textcolor (11);
write (usr,'. ');
exec(getenv('COMSPEC'),'/C MOVE '+MF+' '+MT);
if doserror <> 0 then writeln (usr,'MOVE.COM not found!');
textbackground (0);
for a:=8 to 25 do begin
gotoxy (1,a);
clreol;
end;
end;
procedure bhigh (x:integer);
var c:char;
y,z,a:integer;
dir:string[127];
begin
case x of
1:begin
gotoxy (3,4);
textcolor (15);
textbackground (7);
write (usr,' Handle ');
end;
2:begin
gotoxy (3,5);
textcolor (15);
textbackground (7);
write (usr,' Password ');
end;
3:begin
gotoxy (3,6);
textcolor (15);
textbackground (7);
write (usr,' Main Level ');
end;
4:begin
gotoxy (3,7);
textcolor (15);
textbackground (7);
write (usr,' Xfer Level ');
end;
5:begin
gotoxy (3,8);
textcolor (15);
textbackground (7);
write (usr,' G-File Level ');
end;
6:begin
gotoxy (3,9);
textcolor (15);
textbackground (7);
write (usr,' Xfer Points ');
end;
7:begin
gotoxy (3,10);
textcolor (15);
textbackground (7);
write (usr,' Time Left ');
end;
end;
end;
procedure execcmds;
var c:char;
x,y,z,a:integer;
dir:string[127];
DD:boolean;
begin
z:=1;
dd:=false;
repeat
gotoxy (2,3);
textbackground (1);
textcolor (15);
writeln (usr,'┬──────────────┬');
gotoxy (2,4);
writeln (usr,'│ Handle │');
gotoxy (2,5);
writeln (usr,'│ Password │');
gotoxy (2,6);
writeln (usr,'│ Main Level │');
gotoxy (2,7);
writeln (usr,'│ Xfer Level │');
gotoxy (2,8);
writeln (usr,'│ G-File Level │');
gotoxy (2,9);
writeln (usr,'│ Xfer Points │');
gotoxy (2,10);
writeln (usr,'│ Time Left │');
gotoxy (2,11);
writeln (usr,'└──────────────┘');
textbackground (1);
textcolor (15);
bhigh (z);
repeat
c:=readkey;
c:=upcase(c);
until c in [#77,#75,#72,#80,#27,#13,#3];
if (c=#77) or (c=#80) then z:=z+1;
if (c=#75) or (c=#72) then z:=z-1;
if z=0 then z:=7;
if z=8 then z:=1;
if c=#27 then dd:=true;
if c=#13 then begin
textbackground (0);
gotoxy(1,13);
case z of
1:getnewname;
2:getnewpassword;
3:getnewlevel;
4:getnewudlvl;
5:gfilez;
6:getnewudpts;
7:getnewtime;
end;
gotoxy (1,13); clreol;
gotoxy (1,14); clreol;
gotoxy (1,15); clreol;
gotoxy (1,16); clreol;
gotoxy (1,17); clreol;
gotoxy (1,18); clreol;
gotoxy (1,19); clreol;
gotoxy (1,20); clreol;
gotoxy (1,21); clreol;
gotoxy (1,22); clreol;
gotoxy (1,23); clreol;
end;
until dd=true;
end;
procedure externalcmds;
var c:char;
x,y,z,a:integer;
dir:string[127];
DD:boolean;
procedure bhigh (x:integer);
var c:char;
y,z,a:integer;
dir:string[127];
begin
case x of
1:begin
gotoxy (17,4);
textcolor (15);
textbackground (7);
write (usr,' Run Setup ');
end;
2:begin
gotoxy (17,5);
textcolor (15);
textbackground (7);
write (usr,' Text Editor ');
end;
3:begin
gotoxy (17,6);
textcolor (15);
textbackground (7);
write (usr,' ANSI Editor ');
end;
end;
end;
begin
z:=1; dd:=false;
repeat
gotoxy (16,3);
textbackground (1);
textcolor (15);
writeln (usr,'┬──────────────┬');
gotoxy (16,4);
writeln (usr,'│ Run Setup │');
gotoxy (16,5);
writeln (usr,'│ Text Editor │');
gotoxy (16,6);
writeln (usr,'│ ANSI Editor │');
gotoxy (16,7);
writeln (usr,'└──────────────┘');
textbackground (1);
textcolor (15);
bhigh (z);
repeat
c:=readkey;
c:=upcase(c);
until c in [#77,#75,#72,#80,#27,#13,#3];
if (c=#77) or (c=#80) then z:=z+1;
if (c=#75) or (c=#72) then z:=z-1;
if z=0 then z:=3;
if z=4 then z:=1;
if c=#27 then dd:=true;
if c=#13 then begin
textbackground (0);
clrscr;
case z of
1:runconfig;
2:dotexteditor;
3:doansieditor;
end;
clrscr;
end;
until dd=true;
end;
procedure firstbar;
var c:char;
x,y,z,a,i,ii:integer;
dir:string[127];
done:boolean;
begin
done:=false;x:=1;y:=1;z:=1;
repeat
textbackground (1);
textcolor (15);
gotoxy (1,1);
write (usr,'┌'); for i:=2 to 79 do begin gotoxy (i,1); write (usr,'─'); end;
write (usr,'┐');
gotoxy (1,2);
write (usr,'│ User Editor External Shell to DOS Hang Up Delete User Help Quit │');
gotoxy (1,3);
write (usr,'└'); for i:=2 to 79 do begin gotoxy (i,3); write (usr,'─'); end;
write (usr,'┘');
high (x);
repeat until keypressed;
repeat
c:=readkey;
c:=upcase(c);
until c in [#77,#75,#13,#3,#27];
if c=#27 then done:=true;
if c=#77 then x:=x+1;
if c=#75 then x:=x-1;
if x=8 then x:=1;
if x=0 then x:=7;
if c=#13 then begin
textbackground (0);
case x of
1:execcmds;
2:externalcmds;
3:gotodos;
4:hangupyn;
5:nuke;
6:dohelp;
7:done:=true;
end;
textbackground (0);
clrscr;
end;
until done;
textbackground (0);
end;
begin
cursor (false);
clrscr;
firstbar;
end; {pulldownmenu}
Var scom:sstr;
k:Char;
Begin
writeln (^B^M'Please Wait:');
Pulldownmenu;
clrscr;
cursor (true);
specialcommand:=true;
End;
procedure specialseries;
begin
repeat until specialcommand
end;
procedure chat1 (gotospecial:boolean);
var k:char;
time,cnt,displaywid:integer;
quit,carrierloss,fromkbd:boolean;
baudstr,commstr:mstr;
(*--Variable Definitions----*)
xsys :byte; (*--X location of cursor for sysop--*)
ysys :byte; (*--Y locaiton of cursor for sysop--*)
xusr :byte; (*--X location of cursor for user---*)
yusr :byte; (*--Y location of cursor for user---*)
curcolor :byte; (*--Stores current typists color----*)
ec :byte; (*--Stores old color for speed inc--*)
initi :boolean; (*--Amount of times of initia-------*)
linebufs :string[80]; (*--Storage of what sysop types-----*)
linebufu :string[80]; (*--Storage of what usr types-------*)
(*-Initialization of all the variables takes place-------------------------*)
procedure init;
begin
xsys :=1;
ysys :=4;
xusr :=1;
yusr :=14;
curcolor :=1;
ec :=1;
initi :=true;
linebufs :='';
linebufu :='';
end;
(*-Sends to screen location X,Y depending on values passed as X,Y----------*)
procedure sendxy (x,y:byte);
begin
write(#27+'[',y,';',x,'f');
end;
(*-Sets color if color is same as old, increases speed by not re-setting it*)
Procedure setc;
begin
ec:=urec.inputcolor;
if curcolor<>ec then begin
curcolor:=ec;
modeminlock:=true;
ansicolor (curcolor);
modeminlock:=false;
end;
end;
(*-Clears entire screen via esc[2J-----------------------------------------*)
Procedure clearscre;
var i:byte;
begin
for I:=4 to 22 do
begin
setc;
sendxy(1,i);
write(#27'[K');
end;
end;
function parsedate (date:anystr):lstr;
const months: array[1..12] of string[3]=('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');
var m,d,y,inc,gog:sstr;
year,month,day,dayofweek:word;
begin
if length(date)<>8 then begin
parsedate:=date;
exit;
end else
begin
m:=copy (date,1,2);
d:=copy (date,4,2);
y:=copy (date,7,2);
gog:=months[valu(m)];
getdate (year,month,day,dayofweek);
inc:=copy (strr(year),1,2);
parsedate:=gog+' '+d+' '+inc+y;
end;
end;
(*---Displays middle line in urec.regular color----------------------------*)
procedure midline;
begin
sendxy(1,13);
if asciigraphics in urec.config then
write(^P'───────────────────────────────────────────────────────────────────────────────')
else
write(^P'-------------------------------------------------------------------------------');
sendxy(25,13);
write (^R'[ '^S'FAQ '+ver+^P' - '^S+parsedate(date)+^R' ]')
{sendxy(trunc((21-length(sysopname))/2),13);
write (^R'[ '^S+sysopname+^R' ]');
sendxy(trunc((24-length(urec.handle))/2)+52,13);
write (^R'[ '^S+urec.handle+^R' ]');}
end;
(*-Procedure Clears either lines 4-13 or 14-22 depending on WHERE:boo------*)
Procedure cle (malig:byte);
var i :byte; (*Loop variable - no usage*)
begin
if malig=0 then
begin
for i:=4 to 12 do
begin
sendxy(1,i);
write(#27'[K');
end;
sendxy(1,4);
malig:=0;
midline;
end; (* lines 4-12 *)
if malig=1 then
begin
for i:=14 to 22 do
begin
sendxy(1,i);
write(#27,'[K');
end;
sendxy(1,14);
malig:=0;
midline;
end; (* lines 14-22 *)
(*NOTE: Line 13 is taken up by the middle line *)
end;
procedure wordwrapit(yeanea:byte);
var cnt :byte;
wl :integer;
ww :lstr;
cutarea :byte;
done :boolean;
begin
done:=false;
cutarea:=0;
cnt:=80;
if yeanea=0 then
begin
repeat
if not done and (copy(linebufs,cnt,1)=' ') then cutarea:=cnt;
if (cutarea>0) and not done then
begin
ansicolor(urec.statcolor);
sendxy(cutarea,ysys);
write(#27'[K');
inc(ysys);
xsys:=1;
sendxy(xsys,ysys);
write(copy(linebufs,cutarea+1,80-cutarea));
xsys:=length(copy(linebufs,cutarea+1,80-cutarea))+1;
sendxy(xsys,ysys);
dec(ysys);
done:=true
end; (*If loop *)
dec(cnt); (*decrements c*)
until cnt=1; (*For CNT loop*)
linebufs:='';
end; (*For YEANEA *)
if yeanea=1 then
begin
done:=false;
cutarea:=0;
cnt:=80;
repeat
if not done and (copy(linebufu,cnt,1)=' ') then cutarea:=cnt;
if (cutarea>0) and not done then
begin
ansicolor(urec.inputcolor);
sendxy(cutarea,yusr);
write(#27'[K');
inc(yusr);
xusr:=1;
sendxy(xusr,yusr);
write(copy(linebufu,cutarea+1,80-cutarea));
xusr:=length(copy(linebufu,cutarea+1,80-cutarea))+1;
sendxy(xusr,yusr);
dec(yusr);
done:=true
end; (*If loop *)
dec(cnt); (*decrements c*)
until cnt=1; (*For CNT loop*)
linebufu:='';
end; (*For YEANEA *)
end; (*For wordwrap*)
(*---Places cursor at correct position------------------------------------*)
Procedure locate;
begin
if fromkbd then (*Checks if typed by sysop*)
begin
if (xsys=80) and (ysys<12) then (*Checks if at end of line*)
begin
wordwrapit(0);
inc(ysys);
if not ysys=13 then linebufs:='';
end;
if (ysys=12) and (xsys=80) then
begin
cle(0);
ysys:=4;
xsys:=1;
sendxy(xsys,ysys);
write(linebufs);
sendxy(80-length(linebufs)+1,ysys);
wordwrapit(0);
inc(ysys);
sendxy(xsys,ysys);
end;
sendxy(xsys,ysys);
inc(xsys);
end;
if not fromkbd then (*Checks if typed by user*)
begin
if (xusr=80) and (yusr<22) then (*Checks if at end of line*)
begin
wordwrapit(1);
inc(yusr);
if not yusr=23 then linebufu:='';
end;
if (yusr=22) and (xusr=80) then
begin
cle(1);
yusr:=14;
xusr:=1;
sendxy(xusr,yusr);
write(linebufu);
sendxy(80-length(linebufu)+1,yusr);
wordwrapit(1);
inc(yusr);
sendxy(xusr,yusr);
end;
sendxy(xusr,yusr);
inc(xusr);
end;
end; (*end of procedure*)
procedure instruct;
var i:integer;
begin
for i:=1 to 5 do
begin
sendxy(1,i);
write(#27,'[K');
end;
{splitscreen (3);}
top;
clrscr;
{write (usr,'Now in Chat mode. Press [F1] to leave or [F2] for commands.');}
initi:=false;
bottom;
sendxy(1,4);
end;
procedure typedchar (k:char);
begin
locate; (* Puts cursor in right place *)
begin;
if fromkbd then linebufs:=linebufs+K else linebufu:=linebufu+K;
setc; (* Sets up color for typing *)
write(k)
end;
end;
begin
time:=timeleft;
carrierloss:=false;
chatmode:=false;
writeln (^B^M);
if wanted in urec.config then begin
specialmsg ('No longer wanted.');
urec.config:=urec.config-[wanted];
writeurec;
end;
if eightycols in urec.config then displaywid:=80 else displaywid:=40;
if gotospecial then begin
specialseries;
exit
end;
clearbreak;
nobreak:=true;
writeln (^M^S,appear);
writeln (^R'CHAT '^S'IN '^P'['^S,upstring(Timestr(now)),^P']'^M);
instruct;
if not initi then
begin
init; (* Sets up variables *)
clearscre; (* Clears screen lines 4-22 *)
midline; (* Draws middle line for chat *)
end;
quit:=false;
repeat
linecount:=0;
if (not carrierloss) and (not carrier) then begin
carrierloss:=true;
writeln (^M'There is no carrier present.'^M)
end;
repeat until keyhit or (carrier and (numchars>0));
fromkbd:=keyhit;
ingetstr:=true;
read (directin,k);
if k=#127 then k:=#8;
if requestchat1
then if requestcom
then
begin
quit:=specialcommand;
if not quit then instruct;
clearbreak;
nobreak:=true;
end
else
begin
unsplit;
clearscre;
writeln (^M^S,disappear);
writeln (^R'CHAT '^S'OUT '^P'['^S,upstring(Timestr(now)),^P']'^M^R);
quit:=true
end;
case ord(k) of
8:begin
if (xsys>0) and fromkbd then
begin
modeminlock:=true;
dec(xsys);
sendxy(xsys,ysys);
write (' ');
sendxy(xsys,ysys);
linebufs:=copy(linebufs,1,length(linebufs)-1);
modeminlock:=false;
end;
if (xusr>0) and not fromkbd then
begin
modeminlock:=true;
dec(xusr);
sendxy(xusr,yusr);
write (' ');
sendxy(xsys,ysys);
linebufu:=copy(linebufu,1,length(linebufu)-1);
modeminlock:=false;
end;
end;
0:;
13:begin
writeln;
bottomline;
if fromkbd then begin
xsys:=1;
inc(ysys);
if (ysys=13) and (xusr>-1) then (*Checks if at end of row *)
begin
cle(0);
setc;
ysys:=4;
xsys:=1;
sendxy(xsys,ysys);
write(linebufs);
ysys:=5;
sendxy(xsys,ysys);
setc;
end;
sendxy(xsys,ysys);
linebufs:='';
end;
if not fromkbd then begin
xusr:=1;
inc(yusr);
if (yusr=23) and (xusr>-1) then (*Checks if at end of row *)
begin
cle(1);
setc;
yusr:=14;
xusr:=1;
sendxy(xusr,yusr);
write(linebufu);
yusr:=15;
sendxy(xusr,yusr);
setc;
end;
sendxy(xusr,yusr);
linebufu:='';
end;
end;
32..126:typedchar (k);
1..31:if fromkbd and carrier then sendchar(k)
end
until quit;
clearbreak;
settimeleft (time)
end;
procedure chat2 (gotospecial:boolean);
var k:char;
time,cnt,displaywid:integer;
quit,carrierloss,fromkbd:boolean;
linebuffer:lstr;
l:byte absolute linebuffer;
curcolor:byte;
baudstr,commstr:mstr;
procedure instruct;
begin
{splitscreen (3);}
top;
clrscr;
{write (usr,'Now in Chat mode. Press [F1] to leave or [F2] for commands.');}
bottom
end;
procedure wordwrap;
var cnt,wl:integer;
ww:lstr;
begin
ww:='';
cnt:=displaywid;
while (cnt>0) and (linebuffer[cnt]<>' ') do cnt:=cnt-1;
if cnt=0 then ww:=k else begin
ww:=copy(linebuffer,cnt+1,255);
wl:=length(ww)-1;
if wl>0 then begin
for cnt:=1 to wl do write (^H);
for cnt:=1 to wl do write (' ')
end
end;
writeln;
ansicolor (curcolor);
write (ww);
linebuffer:=ww
end;
procedure typedchar (k:char);
var ec:byte;
begin
l:=l+1;
linebuffer[l]:=k;
if fromkbd then ec:=urec.regularcolor else ec:=urec.inputcolor;
if curcolor<>ec then begin
curcolor:=ec;
ansicolor (curcolor)
end;
if l=displaywid then wordwrap else write(k)
end;
begin
time:=timeleft;
carrierloss:=false;
chatmode:=false;
writeln (^B^M);
if wanted in urec.config then begin
specialmsg ('No longer wanted.');
urec.config:=urec.config-[wanted];
writeurec;
end;
if eightycols in urec.config then displaywid:=80 else displaywid:=40;
if length(chatreason)>0 then specialmsg ('[Chat Reason: '+chatreason+']');
chatreason:='';
if gotospecial then begin
specialseries;
exit
end;
clearbreak;
nobreak:=true;
writeln (^M^S,appear);
writeln (^R'CHAT '^S'IN '^P'['^S,upstring(Timestr(now)),^P']'^M^R);
instruct;
quit:=false;
l:=0;
curcolor:=urec.regularcolor;
repeat
linecount:=0;
if (not carrierloss) and (not carrier) then begin
carrierloss:=true;
writeln (^M'There is no carrier present.'^M)
end;
repeat until keyhit or (carrier and (numchars>0));
fromkbd:=keyhit;
ingetstr:=true;
read (directin,k);
if k=#127 then k:=#8;
if requestchat2
then if requestcom
then
begin
quit:=specialcommand;
if not quit then instruct;
clearbreak;
nobreak:=true;
l:=0
end
else
begin
unsplit;
writeln (^M^S,disappear);
writeln (^R'CHAT '^S'OUT '^P'['^S,upstring(Timestr(now)),^P']'^M);
quit:=true
end;
case ord(k) of
8:if l>0 then begin
write (k+' '+k);
l:=l-1
end;
0:;
13:begin
writeln;
bottomline;
l:=0
end;
32..126:typedchar (k);
1..31:if fromkbd and carrier then sendchar(k)
end
until quit;
clearbreak;
settimeleft (time)
end;
begin
end.